home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / dynamic < prev    next >
Text File  |  1993-04-02  |  3KB  |  74 lines
  1. ; "dynamic.scm", DYNAMIC data type for Scheme
  2. ; Copyright (c) 1992, Andrew Wilcox
  3.  
  4. (require 'record)
  5. (require 'dynamic-wind)
  6.  
  7. (define dynamic-environment-rtd
  8.   (make-record-type "dynamic environment" '(dynamic value parent)))
  9. (define make-dynamic-environment
  10.   (record-constructor dynamic-environment-rtd))
  11. (define dynamic-environment:dynamic
  12.   (record-accessor dynamic-environment-rtd 'dynamic))
  13. (define dynamic-environment:value
  14.   (record-accessor dynamic-environment-rtd 'value))
  15. (define dynamic-environment:set-value!
  16.   (record-modifier dynamic-environment-rtd 'value))
  17. (define dynamic-environment:parent
  18.   (record-accessor dynamic-environment-rtd 'parent))
  19.  
  20. (define *current-dynamic-environment* #f)
  21. (define (extend-current-dynamic-environment dynamic obj)
  22.   (set! *current-dynamic-environment*
  23.     (make-dynamic-environment dynamic obj
  24.                   *current-dynamic-environment*)))
  25.  
  26. (define dynamic-rtd (make-record-type "dynamic" '()))
  27. (define make-dynamic
  28.   (let ((dynamic-constructor (record-constructor dynamic-rtd)))
  29.     (lambda (obj)
  30.       (let ((dynamic (dynamic-constructor)))
  31.     (extend-current-dynamic-environment dynamic obj)
  32.     dynamic))))
  33.  
  34. (define dynamic? (record-predicate dynamic-rtd))
  35. (define (guarantee-dynamic dynamic)
  36.   (or (dynamic? dynamic)
  37.       (slib:error "Not a dynamic" dynamic)))
  38.  
  39. (define dynamic:errmsg
  40.   "No value defined for this dynamic in the current dynamic environment")
  41.  
  42. (define (dynamic-ref dynamic)
  43.   (guarantee-dynamic dynamic)
  44.   (let loop ((env *current-dynamic-environment*))
  45.     (cond ((not env)
  46.        (slib:error dynamic:errmsg dynamic))
  47.       ((eq? (dynamic-environment:dynamic env) dynamic)
  48.        (dynamic-environment:value env))
  49.       (else
  50.        (loop (dynamic-environment:parent env))))))
  51.  
  52. (define (dynamic-set! dynamic obj)
  53.   (guarantee-dynamic dynamic)
  54.   (let loop ((env *current-dynamic-environment*))
  55.     (cond ((not env)
  56.        (slib:error dynamic:errmsg dynamic))
  57.       ((eq? (dynamic-environment:dynamic env) dynamic)
  58.        (dynamic-environment:set-value! env obj))
  59.       (else
  60.        (loop (dynamic-environment:parent env))))))
  61.  
  62. (define (call-with-dynamic-binding dynamic obj thunk)
  63.   (let ((out-thunk-env #f)
  64.     (in-thunk-env (make-dynamic-environment
  65.                dynamic obj
  66.                *current-dynamic-environment*)))
  67.     (dynamic-wind (lambda ()
  68.             (set! out-thunk-env *current-dynamic-environment*)
  69.             (set! *current-dynamic-environment* in-thunk-env))
  70.           thunk
  71.           (lambda ()
  72.             (set! in-thunk-env *current-dynamic-environment*)
  73.             (set! *current-dynamic-environment* out-thunk-env)))))
  74.